home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / TPFORT18.ARJ / FORTLINK.PAS < prev    next >
Pascal/Delphi Source File  |  1992-03-08  |  14KB  |  478 lines
  1. unit fortlink;
  2.  
  3. { TPFORT unit to link in fortran routines.  Version 1.82 }
  4.  
  5. { Version 1.82- Restored 5.0/5.5 compatibility; added UnLoadFort }
  6. { Version 1.81- Added test for valid procedure addresses }
  7. { Version 1.8 - Cleaned up memory management, added version tests and
  8.                 Loaderror variable & messages }
  9. { Version 1.7 - added FortErrorFlag }
  10. { Version 1.5 - added Ext_Pointer function                                   }
  11. { Version 1.4 - added Size_Table types and variable for CHARACTER support    }
  12. { Version 1.3 - fixed bug in loader, and changes type of extra_space to
  13.                 longint }
  14.  
  15.  
  16. { Conditional defines: }
  17.  
  18. {.define OPRO_VER}   { Define this if you own Object Professional. }
  19.  
  20. {$ifdef ver40}
  21.   TPFORT will *not* work with TP 4.0.
  22. {$endif}
  23.  
  24. {$ifdef ver50}
  25.   Warning:  TPFORT has not been tested with TP 5.0.  Remove this line at
  26.   your own risk!
  27.   {$define tp4heap}
  28. {$endif}
  29.  
  30. {$ifdef ver55}
  31.   {$define tp4heap}
  32. {$endif}
  33.  
  34. interface
  35.   uses dos
  36. {$IFNDEF OPRO_VER} ; {$ELSE} ,opint,opdos,opinline; {$ENDIF}
  37.  
  38. type
  39.   extval     = longint;
  40.   double_ptr = ^double;
  41.   realarray  = array[1..65520 div sizeof(double)] of double;
  42.   size_table_array = array[0..65519 div sizeof(word)] of word;
  43.                      { Array of CHARACTER variable sizes.  Note that entry
  44.                        0 seems to be unused. }
  45.   size_table_ptr = ^size_table_array;
  46.  
  47. const
  48.   maxprocs  = 32;  { Recompile this as large as necessary.
  49.                      Overhead is 4*maxprocs }
  50.   extra_space : longint = 1024;  { Extra memory to give to Fortran Loader }
  51.   FortParas   : word = 0;        { Paragraphs currently allocated to Loader }
  52.  
  53.   linkedprocs   : word = 0;  { The number of procedures linked so far.  Use
  54.                                for automatic procedure numbering in unit
  55.                                initializations }
  56.   fortlink_version = 18;
  57.  
  58. var
  59.   fortloaded    : boolean;   { True indicates Fortran routines are in memory }
  60.   fortsafe      : boolean;   { True indicates you're in Fortran mode }
  61.   size_table    : ^size_table_ptr; { Points to __fcclenv; see docs.  }
  62.   FortErrorFlag : ^word;     { Points to _MERRQQ; see docs. }
  63.   calltp_version: word;
  64.   calltp_numprocs:word;
  65.   Loaderror     : word;      { 0 = no error
  66.                                1 = version mismatch (see calltp_version)
  67.                                2 = too many procedures (max = maxprocs)
  68.                                3 = too few procedures (min = linkedprocs)
  69.                                    numprocs
  70.                                4 = badly formed procedure address
  71.                              101 = not enough memory
  72.                              102 = no call back
  73.                              103 = DOS error (read System.DOSError variable)
  74.                            }
  75.  
  76. {  NOT supposed to be interfaced, but external_val needs one }
  77. type
  78.   proc_ref = record
  79.     zero,addr_ofs : word;
  80.   end;
  81.   proc_ref_array = array[1..maxprocs] of proc_ref;
  82.   proc_array = array[1..maxprocs] of pointer;
  83.  
  84.   result = record       { An array of these are stored at FortSS:FortSP }
  85.    case integer of
  86.    1 : (i   : integer);
  87.    2 : (l   : longint);
  88.    3 : (s   : single);
  89.    4 : (d   : double);
  90.   end;
  91.  
  92. var
  93.   numprocs : word;    { The actual number of Fortran procedures linked }
  94.   procs : proc_array; { An array of pointers to them }
  95.   FortStackLimit,
  96.   FortDS,
  97.   FortSS,
  98.   FortSP,
  99.   TPStackLimit : word;
  100.  
  101. function loadfort(prog:string;TPentry:pointer):boolean;
  102. { The procedure to load the Fortran routines.  Returns true on success. }
  103.  
  104. procedure unloadfort;
  105. { Unloads the Fortran routines. }
  106.  
  107. procedure callfort(procnum:word);
  108. { The procedure to call the Fortran routine number procnum }
  109. { Works for SUBROUTINES and FUNCTIONS with values up to 4 bytes (except REAL*4)}
  110.  
  111. procedure fsingle(procnum:word);
  112. { Simulates a Fortran REAL*4 Function call }
  113.  
  114. procedure fdouble(procnum:word);
  115. { Simulates a Fortran Double Precision Function call }
  116.  
  117. procedure fpointer(procnum:word);
  118. { Simulates a Fortran Function call with a value up to 8 bytes long, by
  119.   returning a pointer to it.  Can reserve space for longer return values by
  120.   passing multiple copies of the function to CALLTP, and only using the
  121.   first.
  122. }
  123.  
  124. function fort_external(procnum:word):extval;
  125. { Procedure to return value to be passed as an external reference }
  126. Inline(
  127.   $59/                   {      pop    cx}
  128.   $49/                   {      dec    cx}
  129.   $D1/$E1/               {      shl    cx,1}
  130.   $D1/$E1/               {      shl    cx,1}
  131.   $BB/>PROCS/            {      mov    bx,>procs}
  132.   $01/$CB/               {      add    bx,cx}
  133.   $FF/$77/$02/           {      push   [bx+2]}
  134.   $FF/$37/               {      push   [bx]}
  135.   $31/$C0/               {      xor    ax,ax}
  136.   $89/$E2);              {      mov    dx,sp}
  137.  
  138. function pas_external(proc:pointer):extval;
  139. { Procedure to return value to be passed as an external reference for
  140.   a Pascal procedure - NOT a function
  141. }
  142. Inline(
  143.   $31/$C0/               {      xor    ax,ax}
  144.   $89/$E2);              {      mov    dx,sp}
  145.  
  146. procedure clean_external;
  147. Inline(
  148.   $83/$C4/$04);          {       add sp,4}
  149.  
  150. function ext_pointer(ext:extval):pointer;
  151. { Convert external routine value into pointer to the entry point. }
  152.  
  153. procedure Enter_Pascal;
  154. { Set up Pascal context. Always use with Leave_Pascal! }
  155.  
  156. procedure Leave_Pascal;
  157. { Restore Fortran context. Always use with Enter_Pascal! }
  158. Inline(
  159.   $5F/                   {        pop     di    ;  Restore DI,}
  160.   $5E/                   {        pop     si    ;  SI,        }
  161.   $1F/                   {        pop     ds    ;  DS,        }
  162.   $9D);                  {        popf          ;  and the flags}
  163.  
  164. implementation
  165.  
  166. const
  167.   copyright   : string[49] = 'TPFORT 1.82 copyright (c) 1989-1992, D.J. Murdoch';
  168.   rights      : string[20] = 'All rights reserved.';
  169.  
  170. {$IFNDEF OPRO_VER}
  171. {$I opro.inc}
  172. {$ENDIF}
  173.  
  174. {$l callfort.obj}
  175.  
  176. procedure callfort(procnum:word); external;
  177.  
  178. procedure fsingle(procnum:word); external;
  179.  
  180. procedure fdouble(procnum:word); external;
  181.  
  182. procedure fpointer(procnum:word); external;
  183.  
  184. procedure Enter_Pascal; external;
  185.  
  186. procedure Leave_Pascal; external;
  187.  
  188. function ext_pointer(ext:extval):pointer;
  189. begin
  190.   ext_pointer := ptr(sseg,ext shr 16);
  191. end;
  192.  
  193. procedure SaveTPDS; external;
  194.  
  195. {$f+}
  196. procedure F1_handler(
  197.      Addresses:word;NumArgs:pointer;Return:pointer;  { From CALLTP call }
  198.      MERRQQ:pointer; StackLimit:word;
  199.      FccLenvAddr:pointer; Version:word;              { Added by CALLTP }
  200.      Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP: Word);
  201. interrupt;
  202. var
  203.   procrefs : proc_ref_array absolute addresses;
  204.   i : word;
  205. begin
  206.   InterruptsOn;
  207.   calltp_version := version;
  208.   if version <> fortlink_version then
  209.   begin
  210.     loaderror := 1;
  211.     exit;
  212.   end;
  213.   numprocs := word(numargs^);
  214.   calltp_numprocs := numprocs;
  215.   if numprocs > maxprocs then
  216.   begin
  217.     loaderror := 2;
  218.     exit;
  219.   end;
  220.   if numprocs < linkedprocs then
  221.   begin
  222.     loaderror := 3;
  223.     exit;
  224.   end;
  225.   for i := 1 to numprocs do
  226.   begin
  227.     if procrefs[i].zero <> 0 then
  228.     begin
  229.       loaderror := 4;
  230.       exit;
  231.     end;
  232.     procs[numprocs + 1 - i] := pointer(ptr(DS,procrefs[i].addr_ofs)^);
  233.   end;
  234.   FortErrorFlag  := MERRQQ;
  235.   FortStackLimit := StackLimit;
  236.   FortDS    := DS;
  237.   FortSS    := sseg;
  238.   FortSP    := ofs(procrefs[numprocs])
  239.                + sizeof(proc_ref)           { This removes the procedure
  240.                                               references from the stack, }
  241.                - numprocs*(sizeof(result)); { and leaves room for saved
  242.                                               results }
  243.   Size_Table := FccLenvAddr;
  244.   fortloaded:= true;
  245.   loaderror := 0;
  246. end;
  247. {$f-}
  248.  
  249. procedure UseFortStack(var Regs:Intregisters);
  250. { This routine sets us up in the Fortran stack, then calls the TPentry routine }
  251. begin
  252.   TPStackLimit := system.stacklimit;
  253.   system.stacklimit := FortStackLimit;
  254.   FortSafe := true;
  255.   FarCall(ptr(regs.CS,regs.IP));
  256.   FortSafe := false;
  257.   system.stacklimit := TPStackLimit;
  258. end;
  259.  
  260. function env_paras:word;
  261. var
  262.   env_seg_mcb : word;
  263. begin
  264.   env_seg_mcb := memw[prefixseg:$2c] - 1;
  265.   env_paras   := memw[env_seg_mcb:3];
  266. end;
  267.  
  268. function mem_needed(prog:string):longint;
  269. {  Function to calculate the number of paragraphs required to load the program
  270.    whose path is given in prog }
  271. type
  272.   exe_header = record
  273.     sig,
  274.     remainder,
  275.     pages,
  276.     relocs,
  277.     header,
  278.     min_extra : word;
  279.   end;
  280.  
  281. var
  282.   p : file of exe_header;
  283.   h : exe_header;
  284. begin
  285.   mem_needed := 0;
  286.   assign(p,prog);
  287.   {$i-} reset(p);
  288.         read(p,h);
  289.         close(p);
  290.   {$i+}
  291.   if ioresult <> 0 then
  292.     exit;
  293.  
  294.   with h do
  295.   begin
  296.     if sig = $5a4d then
  297.     begin
  298.       if remainder in [0,4] then
  299.         remainder := 512;
  300.       mem_needed := longint(pages)*512 - 16*longint(header)
  301.                    + 16*longint(min_extra) - (512-longint(remainder))
  302.                                                   { Load image size }
  303.              + 32                                 { two MCBs        }
  304.              + 16*longint(env_paras)              { a new environment }
  305.              + extra_space;
  306.  
  307.     end
  308.     else
  309.       exit;
  310.   end;
  311. end;
  312.  
  313. {$IfDef TP4Heap}
  314.  
  315. Function MemTop:Pointer;
  316. begin
  317.   MemTop := Ptr(Seg(FreePtr^)+$1000,0);
  318. end;
  319.  
  320. Function HeapEnd:Pointer;
  321. Begin
  322.   if Ofs(FreePtr^) = 0 then
  323.     HeapEnd := MemTop
  324.   else
  325.     HeapEnd := Normalized(FreePtr);
  326. end;
  327.  
  328. Function FreeListSize:Word;
  329. Begin
  330.   FreeListSize:=PtrDiff(MemTop,HeapEnd);
  331.   writeln('Free list size = ',PtrDiff(MemTop,HeapEnd));
  332. End;
  333. {$EndIf}
  334.  
  335. function loadfort(prog:string;TPentry:pointer):boolean;
  336. const
  337.   link_vector = $F1;
  338.   link_handle = 16;
  339.   all_of_memory : word = $FFFF;
  340. var
  341.   regs : IntRegisters;
  342.   execblock : pointer;
  343.   blocksize : longint;
  344.   state87 : array[1..94] of byte;
  345.   ParasWeHave : word;
  346.   ParasWeWant : word;
  347.   ParasAvailable : word;
  348. {$ifdef TP4Heap}
  349.   NewFreePtr : pointer;
  350. {$endif}
  351. begin
  352.   loadfort := false;
  353.   if not fortloaded then
  354.   begin
  355.     writeln(copyright);
  356.     if not InitVector(link_vector,link_handle,@f1_handler) then
  357.     begin
  358.       writeln('Can''t get F1! Aborting.');
  359.       exit;
  360.     end;
  361.  
  362.     blocksize := mem_needed(prog);
  363.     if blocksize = 0 then
  364.       writeln('Can''t determine memory requirements! Will attempt to load...')
  365.     else
  366.     begin
  367.       {Current DOS memory allocation read from memory control block}
  368.       ParasWeHave := MemW[Pred(PrefixSeg):3];
  369.       FortParas   := blocksize div 16;
  370.       ParasWeWant := ParasWeHave - FortParas;
  371.       ParasAvailable := PtrDiff(HeapEnd,HeapPtr) div 16;
  372.  
  373.       if (ParasAvailable < ParasWeWant) or (not SetBlock(ParasWeWant)) then
  374.       begin
  375.         writeln('Not enough memory available to load ',prog);
  376.         writeln('Needed: ',blocksize,' Available: ',ParasAvailable*16);
  377.         loaderror := 101;
  378.         exit;
  379.       end;
  380.  
  381.       { Shrink the heap }
  382.  
  383. {$ifdef TP4Heap}
  384.       {Copy the free list and its pointer down}
  385.       NewFreePtr:=Ptr(Seg(FreePtr^)-FortParas,Ofs(FreePtr^));
  386.       Move(FreePtr^,NewFreePtr^,FreeListSize);
  387.       FreePtr:=NewFreePtr;
  388. {$else}
  389.       Heapend := Ptr(seg(HeapEnd^)-FortParas,ofs(HeapEnd^));
  390. {$endif}
  391.     end;
  392.  
  393.     writeln('Executing Fortran loader...');
  394.     loaderror := 102;  { Prepare for no call back }
  395.  
  396.     { Save 8087 state }
  397.     Inline($cd/$39/$B6/state87);   {        fsave word ptr [bp+state87]}
  398.  
  399.     swapvectors;
  400.     exec(prog,'');
  401.     swapvectors;
  402.  
  403.     { Restore 8087 state }
  404.     Inline($cd/$39/$A6/state87);   {        frstor word ptr [bp+state87]}
  405.  
  406.     RestoreVector(link_handle);
  407.  
  408.     if doserror <> 0 then
  409.     begin
  410.       writeln('DOS error ',doserror,' on exec.');
  411.       loaderror := 103;
  412.       exit;
  413.     end;
  414.  
  415.     if not fortloaded then
  416.     begin
  417.       write('ERROR ',loaderror,':  ');
  418.       case loaderror of
  419.          1 : writeln('FORTLINK version ',fortlink_version,' CALLTP version ',
  420.                      calltp_version);
  421.          2 : writeln('Too many procedures: CALLTP.numprocs=',calltp_numprocs,
  422.                      ' max=',maxprocs);
  423.          3 : writeln('Too few procedures: CALLTP.numprocs=',calltp_numprocs,
  424.                      ' FORTLINK.Linkedprocs =',linkedprocs);
  425.          4 : writeln('Bad procedure address.  Use EXTERNAL; use /Gb flag in MS Fortran 5.1.');
  426.        102 : writeln('No CALLTP call.');
  427.        else
  428.          writeln('Unknown.');
  429.       end;
  430.       exit;
  431.     end;
  432.  
  433.     if not Setblock(ParasWeHave) then
  434.       writeln('Warning: unable to reclaim memory');
  435.  
  436.     { Copy the emulator data to the Fortran segment }
  437.     move(ptr(sseg,0)^,ptr(FortSS,0)^,system.stacklimit);
  438.   end;
  439.  
  440.   Regs.IP := ofs(TPEntry^);
  441.   Regs.CS := seg(TPEntry^);
  442.  
  443.   SwapStackAndCallNear(ofs(UseFortstack), ptr(FortSS,FortSP), Regs);
  444.  
  445.   loadfort := true;
  446. end;
  447.  
  448. Procedure UnloadFort;
  449. {$ifdef TP4Heap}
  450. Var
  451.   NewFreePtr:Pointer;
  452. {$endif}
  453. Begin
  454.   If Fortloaded and (not FortSafe) then
  455.   Begin
  456. {$Ifdef TP4heap}
  457.     {Copy the free list and its pointer up}
  458.     NewFreePtr:=Ptr(Seg(FreePtr^)+FortParas,Ofs(FreePtr^));
  459.     Move(FreePtr^,NewFreePtr^,FreeListSize);
  460.     FreePtr:=NewFreePtr;
  461. {$else}
  462.     {Restore original HeapEnd}
  463.     HeapEnd:=Ptr(Seg(HeapEnd^)+FortParas,Ofs(HeapEnd^));
  464. {$EndIf}
  465.     FortParas := 0;
  466.     Fortloaded:=False;
  467.   End;
  468. End;
  469.  
  470. begin
  471.   fortloaded := false;
  472.   fortsafe   := false;
  473.   SaveTPDS;
  474. {$IFNDEF OPRO_VER}
  475.   opint_init;
  476. {$ENDIF}
  477. end.
  478.